home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
QRZ! Ham Radio 8
/
QRZ Ham Radio Callsign Database - Volume 8.iso
/
mac
/
files
/
ant_nec
/
nec81tar.z
/
nec81tar
/
netwk.f
< prev
next >
Wrap
Text File
|
1991-05-13
|
18KB
|
655 lines
C $TITLE: 'NETWK'
C $NOFLOATCALLS
C
C
C
SUBROUTINE NETWK(CM,CMB,CMC,CMD,EINC,RHS,SCRATC,
1 AIR,AII,BIR,BII,CIR,CII,T1X,T1Y,T1Z,T2X,T2Y,T2Z,BI,
2 ICON1,ICON2,ITAG,IP,IW,LD,LD2,LD3,IRESRV)
C
C SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN
C EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF
C PRESENT.
C
REAL*8 TP,AIR,AII,BIR,BII,CIR,CII,ASA,ASM,PWR
CLARGE: CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
COMPLEX CM,CMB,CMC,CMD,CMN,EINC,RHS,RHNT
COMPLEX*16 SCRATC
COMPLEX*16 VQD,VSANT,VQDS
COMPLEX*16 VSRC,RHNX,ZPED
COMPLEX*16 YMIT,VLT,CUX
INTEGER*4 NEQ,NPEQ,NEQ2,NTEQ,NDIMN,NEQT
INTEGER*4 ICON1,ICON2,ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
1 IQDS(30),NVQD,NSANT,NQDS
COMMON/NETCX/ZPED,PIN,PNLS,NEQ,NPEQ,NEQ2,NONET,NTSOL,NPRINT,
1 MASYM,ISEG1(30),ISEG2(30),X11R(30),X11I(30),X12R(30),X12I(30),
2 X22R(30),X22I(30),NTYP(30)
COMMON/NETWKC/CMN(30,30),RHNT(30),IPNT(30),NTEQA(30),NTSCA(30),
1 VSRC(30),RHNX(30),NAMPRT
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
DIMENSION CM(IRESRV),EINC(LD3),CMB(1),CMC(1),CMD(1),SCRATC(LD2),
1 RHS(LD3),IP(LD2),ICON1(LD),ICON2(LD),ITAG(LD)
C**
C $NODEBUG
C**
C DATA NDIMN,NDIMNP/30,31/,TP/6.283185308D0/
DATA NDIMN,NDIMNP/100,101/,TP/6.283185308D0/
C**
C D WRITE(*,*) ' NETWK: START'
C**
$DEBUG
C**
NEQZ2=NEQ2
IF(NEQZ2.EQ.0)NEQZ2=1
PIN=0.
PNLS=0.
NEQT=NEQ+NEQ2
IF (NTSOL.NE.0) GO TO 42
NOP=NEQ/NPEQ
C**
IF((MASYM.EQ.0).OR.(NAMPRT.NE.0)) GO TO 14
C
C COMPUTE RELATIVE MATRIX ASYMMETRY
C
C**
C D WRITE(*,*) ' NETWK: COMPUTE RELATIVE MATRIX ASYMMETRY'
C**
IROW1=0
IF (NONET.EQ.0) GO TO 5
DO 4 I=1,NONET
NSEG1=ISEG1(I)
DO 3 ISC1=1,2
IF (IROW1.EQ.0) GO TO 2
DO 1 J=1,IROW1
IF (NSEG1.EQ.IPNT(J)) GO TO 3
1 CONTINUE
2 IROW1=IROW1+1
IPNT(IROW1)=NSEG1
3 NSEG1=ISEG2(I)
4 CONTINUE
5 IF (NSANT.EQ.0) GO TO 9
DO 8 I=1,NSANT
NSEG1=ISANT(I)
IF (IROW1.EQ.0) GO TO 7
DO 6 J=1,IROW1
IF (NSEG1.EQ.IPNT(J)) GO TO 8
6 CONTINUE
7 IROW1=IROW1+1
IPNT(IROW1)=NSEG1
8 CONTINUE
9 IF (IROW1.LT.NDIMNP) GO TO 10
WRITE(IW,59)
STOP
10 IF (IROW1.LT.2) GO TO 14
DO 12 I=1,IROW1
ISC1=IPNT(I)
ASM=T1X(ISC1)
DO 11 J=1,NEQT
11 RHS(J)= CMPLX(0.,0.)
RHS(ISC1)= CMPLX(1.,0.)
C**
C D WRITE(*,*) ' NETWK: CALL SOLGF AFTER 11'
C**
CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
1 NEQZ2,IP,LD2,LD3,IRESRV)
C**
C D WRITE(*,*) ' NETWK: RTRN SOLGF AFTER 11'
C D WRITE(*,*) ' NETWK: CALL CABC AFTER 11'
C**
CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
C D WRITE(*,*) ' NETWK: RTRN CABC AFTER 11'
C**
DO 12 J=1,IROW1
ISC1=IPNT(J)
12 CMN(J,I)=RHS(ISC1)/ASM
ASM=0.
ASA=0.
DO 13 I=2,IROW1
ISC1=I-1
DO 13 J=1,ISC1
CUX=CMN(I,J)
C PWR=CABS((CUX-CMN(J,I))/CUX)
PWR=ZABS((CUX-CMN(J,I))/CUX)
ASA=ASA+PWR*PWR
IF (PWR.LT.ASM) GO TO 13
ASM=PWR
NTEQ=IPNT(I)
NTSC=IPNT(J)
13 CONTINUE
C**
ASA=DSQRT(ASA*2./FLOAT(IROW1*(IROW1-1)))
WRITE(IW,58) ASM,NTEQ,NTSC,ASA
14 IF (NONET.EQ.0) GO TO 48
C
C SOLUTION OF NETWORK EQUATIONS
C
DO 15 I=1,NDIMN
RHNX(I)=DCMPLX(0.,0.)
DO 15 J=1,NDIMN
15 CMN(I,J)= CMPLX(0.,0.)
NTEQ=0
NTSC=0
C
C SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO
C SEGMENTS.
C
DO 38 J=1,NONET
NSEG1=ISEG1(J)
NSEG2=ISEG2(J)
IF (NTYP(J).GT.1) GO TO 16
Y11R=X11R(J)
Y11I=X11I(J)
Y12R=X12R(J)
Y12I=X12I(J)
Y22R=X22R(J)
Y22I=X22I(J)
GO TO 17
16 Y22R=TP*X11I(J)/WLAM
Y12R=0.
Y12I=1./(X11R(J)*SIN(Y22R))
Y11R=X12R(J)
Y11I=-Y12I*COS(Y22R)
Y22R=X22R(J)
Y22I=Y11I+X22I(J)
Y11I=Y11I+X12I(J)
IF (NTYP(J).EQ.2) GO TO 17
Y12R=-Y12R
Y12I=-Y12I
17 IF (NSANT.EQ.0) GO TO 19
DO 18 I=1,NSANT
IF (NSEG1.NE.ISANT(I)) GO TO 18
ISC1=I
GO TO 22
18 CONTINUE
19 ISC1=0
IF (NTEQ.EQ.0) GO TO 21
DO 20 I=1,NTEQ
IF (NSEG1.NE.NTEQA(I)) GO TO 20
IROW1=I
GO TO 25
20 CONTINUE
21 NTEQ=NTEQ+1
IROW1=NTEQ
NTEQA(NTEQ)=NSEG1
GO TO 25
22 IF (NTSC.EQ.0) GO TO 24
DO 23 I=1,NTSC
IF (NSEG1.NE.NTSCA(I)) GO TO 23
IROW1=NDIMNP-I
GO TO 25
23 CONTINUE
24 NTSC=NTSC+1
IROW1=NDIMNP-NTSC
NTSCA(NTSC)=NSEG1
VSRC(NTSC)=VSANT(ISC1)
25 IF (NSANT.EQ.0) GO TO 27
DO 26 I=1,NSANT
IF (NSEG2.NE.ISANT(I)) GO TO 26
ISC2=I
GO TO 30
26 CONTINUE
27 ISC2=0
IF (NTEQ.EQ.0) GO TO 29
DO 28 I=1,NTEQ
IF (NSEG2.NE.NTEQA(I)) GO TO 28
IROW2=I
GO TO 33
28 CONTINUE
29 NTEQ=NTEQ+1
IROW2=NTEQ
NTEQA(NTEQ)=NSEG2
GO TO 33
30 IF (NTSC.EQ.0) GO TO 32
DO 31 I=1,NTSC
IF (NSEG2.NE.NTSCA(I)) GO TO 31
IROW2=NDIMNP-I
GO TO 33
31 CONTINUE
32 NTSC=NTSC+1
IROW2=NDIMNP-NTSC
NTSCA(NTSC)=NSEG2
VSRC(NTSC)=VSANT(ISC2)
33 IF (NTSC+NTEQ.LT.NDIMNP) GO TO 34
WRITE(IW,59)
STOP
C
C FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH
C NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS.
C
34 IF (ISC1.NE.0) GO TO 35
CMN(IROW1,IROW1)=CMN(IROW1,IROW1)-CMPLX(Y11R,Y11I)*T1X(NSEG1)
CMN(IROW1,IROW2)=CMN(IROW1,IROW2)-CMPLX(Y12R,Y12I)*T1X(NSEG1)
GO TO 36
35 RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y11R,Y11I)*VSANT(ISC1)/WLAM
RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y12R,Y12I)*VSANT(ISC1)/WLAM
36 IF (ISC2.NE.0) GO TO 37
CMN(IROW2,IROW2)=CMN(IROW2,IROW2)-CMPLX(Y22R,Y22I)*T1X(NSEG2)
CMN(IROW2,IROW1)=CMN(IROW2,IROW1)-CMPLX(Y12R,Y12I)*T1X(NSEG2)
GO TO 38
37 RHNX(IROW1)=RHNX(IROW1)+DCMPLX(Y12R,Y12I)*VSANT(ISC2)/WLAM
RHNX(IROW2)=RHNX(IROW2)+DCMPLX(Y22R,Y22I)*VSANT(ISC2)/WLAM
38 CONTINUE
C
C ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
C MATRIX
C
DO 41 I=1,NTEQ
DO 39 J=1,NEQT
39 RHS(J)=(0.,0.)
IROW1=NTEQA(I)
RHS(IROW1)= CMPLX(1.,0.)
C**
C D WRITE(*,*) ' NETWK: CALL SOLGF AFTER 39'
C**
CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
1 NEQZ2,IP,LD2,LD3,IRESRV)
C**
C D WRITE(*,*) ' NETWK: RTRN SOLGF AFTER 39'
C D WRITE(*,*) ' NETWK: CALL CABC AFTER 39'
C**
CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
C D WRITE(*,*) ' NETWK: RTRN CABC AFTER 39'
C**
DO 40 J=1,NTEQ
IROW1=NTEQA(J)
40 CMN(I,J)=CMN(I,J)+RHS(IROW1)
41 CONTINUE
C
C FACTOR NETWORK EQUATION MATRIX
C
CALL FACTR(CMN,SCRATC,NTEQ,NDIMN,IPNT,LD2)
C
C ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT
C INTERACTIONS
C
42 IF (NONET.EQ.0) GO TO 48
DO 43 I=1,NEQT
RHS(I)=EINC(I)
43 CONTINUE
C**
C D WRITE(*,*) ' NETWK: CALL SOLGF, CABC AFTER 43'
C**
CALL SOLGF(CM,CMB,CMC,CMD,RHS,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
1 NEQZ2,IP,LD2,LD3,IRESRV)
CALL CABC(RHS,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
DO 44 I=1,NTEQ
IROW1=NTEQA(I)
44 RHNT(I)=RHNX(I)+RHS(IROW1)
C
C SOLVE NETWORK EQUATIONS
C
C**
C D WRITE(*,*) ' NETWK: CALL SOLVE'
C**
CALL SOLVE(CMN,RHNT,SCRATC,NTEQ,NDIMN,IPNT,LD2)
C**
C D WRITE(*,*) ' NETWK: RTRN SOLVE'
C**
C ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO
C STRUCTURE AND SOLVE FOR INDUCED CURRENT
C
DO 45 I=1,NTEQ
IROW1=NTEQA(I)
EINC(IROW1)=EINC(IROW1)-RHNT(I)
45 CONTINUE
C**
C D WRITE(*,*) ' NETWK: CALL SOLGF, CABC AFTER 45'
C**
CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
1 NEQZ2,IP,LD2,LD3,IRESRV)
CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,61)
IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,60)
DO 46 I=1,NTEQ
IROW1=NTEQA(I)
VLT=RHNT(I)*T1X(IROW1)*WLAM
CUX=EINC(IROW1)*WLAM
YMIT=CUX/VLT
ZPED=VLT/CUX
IROW2=ITAG(IROW1)
PWR=.5*DREAL(VLT*DCONJG(CUX))
PNLS=PNLS-PWR
46 IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62) IROW2,IROW1,
1 VLT,CUX,ZPED,YMIT,PWR
IF (NTSC.EQ.0) GO TO 49
DO 47 I=1,NTSC
IROW1=NTSCA(I)
VLT=VSRC(I)
CUX=EINC(IROW1)*WLAM
YMIT=CUX/VLT
ZPED=VLT/CUX
IROW2=ITAG(IROW1)
PWR=.5*DREAL(VLT*DCONJG(CUX))
PNLS=PNLS-PWR
47 IF((NPRINT.EQ.0).AND.(NAMPRT.EQ.0)) WRITE(IW,62) IROW2,IROW1,
1 VLT,CUX,ZPED,YMIT,PWR
GO TO 49
C
C SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT
C
48 CONTINUE
C**
C D WRITE(*,*) ' NETWK: CALL SOLGF, CABC AFTER 48'
C**
CALL SOLGF(CM,CMB,CMC,CMD,EINC,SCRATC,NP,N1,N,MP,M1,M,NEQ,NEQ2,
1 NEQZ2,IP,LD2,LD3,IRESRV)
CALL CABC(EINC,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C**
NTSC=0
49 IF (NSANT+NVQD.EQ.0) RETURN
IF(NAMPRT.EQ.0) WRITE(IW,63)
IF(NAMPRT.EQ.0) WRITE(IW,60)
IF (NSANT.EQ.0) GO TO 56
DO 55 I=1,NSANT
ISC1=ISANT(I)
VLT=VSANT(I)
IF (NTSC.EQ.0) GO TO 51
DO 50 J=1,NTSC
IF (NTSCA(J).EQ.ISC1) GO TO 52
50 CONTINUE
51 CUX=EINC(ISC1)*WLAM
IROW1=0
GO TO 54
52 IROW1=NDIMNP-J
CUX=RHNX(IROW1)
DO 53 J=1,NTEQ
53 CUX=CUX-CMN(J,IROW1)*RHNT(J)
CUX=(EINC(ISC1)+CUX)*WLAM
54 YMIT=CUX/VLT
ZPED=VLT/CUX
PWR=.5*DREAL(VLT*DCONJG(CUX))
PIN=PIN+PWR
IF (IROW1.NE.0) PNLS=PNLS+PWR
IROW2=ITAG(ISC1)
55 IF(NAMPRT.EQ.0) WRITE(IW,62) IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
56 IF (NVQD.EQ.0) RETURN
DO 57 I=1,NVQD
ISC1=IVQD(I)
VLT=VQD(I)
CUX=DCMPLX(AIR(ISC1),AII(ISC1))
YMIT=DCMPLX(BIR(ISC1),BII(ISC1))
ZPED=CMPLX(CIR(ISC1),CII(ISC1))
PWR=T1X(ISC1)*TP*.5
CUX=(CUX-YMIT*DSIN(PWR)+ZPED*DCOS(PWR))*WLAM
YMIT=CUX/VLT
ZPED=VLT/CUX
PWR=.5*DREAL(VLT*DCONJG(CUX))
PIN=PIN+PWR
IROW2=ITAG(ISC1)
57 IF(NAMPRT.EQ.0) WRITE(IW,64) IROW2,ISC1,VLT,CUX,ZPED,YMIT,PWR
C**
C D WRITE(*,*) ' NETWK: RETURN AT END'
C**
RETURN
C
58 FORMAT (///,3X,47HMAXIMUM RELATIVE ASYMMETRY OF THE DRIVING POINT,
121H ADMITTANCE MATRIX IS,1P,E10.3,13H FOR SEGMENTS,I5,
24H AND,I5,/,3X,25HRMS RELATIVE ASYMMETRY IS,E10.3)
59 FORMAT (1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL')
60 FORMAT (/,3X,3HTAG,3X,4HSEG.,4X,15HVOLTAGE (VOLTS),9X,14HCURRENT (
1AMPS),9X,16HIMPEDANCE (OHMS),8X,17HADMITTANCE (MHOS),6X,5HPOWER,/,
23X,3HNO.,3X,3HNO.,4X,4HREAL,8X,5HIMAG.,3(7X,4HREAL,8X,5HIMAG.),5X,
37H(WATTS))
61 FORMAT (///,27X,66H- - - STRUCTURE EXCITATION DATA AT NETWORK CONN
1ECTION POINTS - - -)
62 FORMAT (2(1X,I5),1P,9E12.5)
63 FORMAT (///,42X,36H- - - ANTENNA INPUT PARAMETERS - - -)
64 FORMAT (1X,I5,2H *,I4,1P,9E12.5)
END
C
C
C
SUBROUTINE CABC(CURX,BI,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 AIR,AII,BIR,BII,CIR,CII,ICON1,ICON2,LD,LD3)
C
C CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND
C COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE
C CURRENT VECTOR CUR.
C
REAL*8 TP,CCJX,AX,BX,CX,AIR,AII,BIR,BII,CIR,CII,AR,AI,SH
CLARGE CURX
COMPLEX CURX
COMPLEX*16 CCJ
COMPLEX*16 VQD,VSANT,VQDS
COMPLEX*16 CURD,CS1,CS2
INTEGER*4 ICON1,ICON2,N1,N2,N,NP,M1,M2,M,MP,IPSYM
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
1 IPCON(10),NPCON
COMMON/VSORC/VQD(30),VSANT(30),VQDS(30),IVQD(30),ISANT(30),
1 IQDS(30),NVQD,NSANT,NQDS
DIMENSION CURX(LD3),CCJX(2),ICON1(LD),ICON2(LD)
DIMENSION AIR(LD),AII(LD),BIR(LD),BII(LD),CIR(LD),CII(LD)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD),BI(LD)
EQUIVALENCE (CCJ,CCJX)
DATA TP/6.283185308D0/,CCJX/0.,-0.01666666667D0/
C**
C E WRITE(*,*) ' CABC: START'
C**
IF (N.EQ.0) GO TO 6
DO 1 I=1,N
AIR(I)=0.
AII(I)=0.
BIR(I)=0.
BII(I)=0.
CIR(I)=0.
CII(I)=0.
1 CONTINUE
C**
DO 2 I=1,N
C AR=DREAL(CURX(I))
C AI=DIMAG(CURX(I))
AR=REAL(CURX(I))
AI=IMAG(CURX(I))
IDM1=1
CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
DO 2 JX=1,JSNO
J=JCO(JX)
AIR(J)=AIR(J)+AX(JX)*AR
AII(J)=AII(J)+AX(JX)*AI
BIR(J)=BIR(J)+BX(JX)*AR
BII(J)=BII(J)+BX(JX)*AI
CIR(J)=CIR(J)+CX(JX)*AR
CII(J)=CII(J)+CX(JX)*AI
2 CONTINUE
IF (NQDS.EQ.0) GO TO 4
C**
IDM1=0
DO 3 IS=1,NQDS
I=IQDS(IS)
JXX=ICON1(I)
ICON1(I)=0
CALL TBF(T1X,BI,ICON1,ICON2,IDM1,I,LD)
ICON1(I)=JXX
SH=T1X(I)*.5
CURD=CCJ*VQDS(IS)/((DLOG(2.*SH/BI(I))-1.)*(BX(JSNO)*DCOS(TP*SH)
1 +CX(JSNO)*DSIN(TP*SH))*WLAM)
AR=DREAL(CURD)
AI=DIMAG(CURD)
DO 3 JX=1,JSNO
J=JCO(JX)
AIR(J)=AIR(J)+AX(JX)*AR
AII(J)=AII(J)+AX(JX)*AI
BIR(J)=BIR(J)+BX(JX)*AR
BII(J)=BII(J)+BX(JX)*AI
CIR(J)=CIR(J)+CX(JX)*AR
CII(J)=CII(J)+CX(JX)*AI
3 CONTINUE
4 CONTINUE
DO 5 I=1,N
CURX(I)=CMPLX(AIR(I)+CIR(I),AII(I)+CII(I))
5 CONTINUE
6 CONTINUE
IF (M.EQ.0) RETURN
C CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
K=LD-M
JCO1=N+2*M+1
JCO2=JCO1+M
DO 7 I=1,M
K=K+1
JCO1=JCO1-2
JCO2=JCO2-3
CS1=CURX(JCO1)
CS2=CURX(JCO1+1)
CURX(JCO2)=CS1*T1X(K)+CS2*T2X(K)
CURX(JCO2+1)=CS1*T1Y(K)+CS2*T2Y(K)
7 CURX(JCO2+2)=CS1*T1Z(K)+CS2*T2Z(K)
RETURN
END
C
C
C
SUBROUTINE SOLGF(A,B,C,D,XY,Y,NP,N1,N,MP,M1,M,N1C,N2C,N2CZ,
1 IP,LD2,LD3,IRESRV)
C SOLVE FOR CURRENT IN N.G.F. PROCEDURE
INTEGER*4 NP,N1,N,MP,M1,M,N1C,N2C
REAL*8 AX,BX,CX
CLARGE: A,B,C,D,XY
COMPLEX A,B,C,D,XY
COMPLEX*16 Y,SUM
DIMENSION B(N1C,1),C(N1C,1),D(N2CZ,1),XY(LD3),
1 IP(LD2),Y(LD2)
COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
1 IPCON(10),NPCON
INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
IFL=14
IF (ICASX.GT.0) IFL=13
C**
C D WRITE(*,*) ' SOLGF: START IFL=',IFL,' ICASX=',ICASX,' N2C=',N2C
C**
IF (N2C.GT.0) GO TO 1
C NORMAL SOLUTION. NOT N.G.F.
CALL SOLVES(A,XY,Y,N1C,NP,N,MP,M,IP,1,13,IFL,LD2,IRESRV)
GOTO 22
1 IF (N1.EQ.N.OR.M1.EQ.0) GO TO 5
C REORDER EXCITATION ARRAY
N2=N1+1
JJ=N+1
NPM=N+2*M1
DO 2 I=N2,NPM
2 Y(I)=XY(I)
J=N1
DO 3 I=JJ,NPM
J=J+1
3 XY(J)=Y(I)
DO 4 I=N2,N
J=J+1
4 XY(J)=Y(I)
5 NEQS=NSCON+2*NPCON
IF (NEQS.EQ.0) GO TO 7
NEQ=N1C+N2C
NEQS=NEQ-NEQS+1
C COMPUTE INV(A)E1
DO 6 I=NEQS,NEQ
6 XY(I)=(0.,0.)
7 CALL SOLVES(A,XY,Y,N1C,NP,N1,MP,M1,IP,1,13,IFL,LD2,IRESRV)
NI=0
NPB=NPBL
C COMPUTE E2-C(INV(A)E1)
DO 10 JJ=1,NBBL
IF (JJ.EQ.NBBL) NPB=NLBL
IF (ICASX.GT.1) READ (15) ((C(I,J),I=1,N1C),J=1,NPB)
II=N1C+NI
DO 9 I=1,NPB
SUM=(0.,0.)
DO 8 J=1,N1C
8 SUM=SUM+C(J,I)*XY(J)
J=II+I
9 XY(J)=XY(J)-SUM
10 NI=NI+NPBL
C**
C D WRITE(*,*) ' SOLGF: OPEN 15'
C**
OPEN (15,FORM='UNFORMATTED')
JJ=N1C+1
C COMPUTE INV(D)(E2-C(INV(A)E1)) = I2
IF (ICASX.GT.1) GO TO 11
CALL SOLVE(D,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
GO TO 13
11 IF (ICASX.EQ.4) GO TO 12
NI=N2C*N2C
READ (11) (B(J,1),J=1,NI)
REWIND 11
CALL SOLVE(B,XY(JJ),Y,N2C,N2C,IP(JJ),LD2)
GO TO 13
12 NBLSYS=NBLSYM
NPSYS=NPSYM
NLSYS=NLSYM
ICASS=ICASE
NBLSYM=NBBL
NPSYM=NPBL
NLSYM=NLBL
ICASE=3
REWIND 11
C**
C D WRITE(*,*) ' SOLGF: OPEN 16'
C**
OPEN (16,FORM='UNFORMATTED')
C**
C D WRITE(*,*) ' SOLGF: CALL LTSOLV'
C**
CALL LTSOLV (B,XY(JJ),Y,IP(JJ),N2C,N2C,1,11,16,LD2)
C**
C D WRITE(*,*) ' SOLGF: RTRN LTSOLV'
C**
REWIND 11
REWIND 16
NBLSYM=NBLSYS
NPSYM=NPSYS
NLSYM=NLSYS
ICASE=ICASS
13 NI=0
NPB=NPBL
C COMPUTE INV(A)E1-(INV(A)B)I2 = I1
DO 16 JJ=1,NBBL
IF (JJ.EQ.NBBL) NPB=NLBL
IF (ICASX.GT.1) READ (14) ((B(I,J),I=1,N1C),J=1,NPB)
II=N1C+NI
DO 15 I=1,N1C
SUM=(0.,0.)
DO 14 J=1,NPB
JP=II+J
14 SUM=SUM+B(I,J)*XY(JP)
15 XY(I)=XY(I)-SUM
16 NI=NI+NPBL
C**
C D WRITE(*,*) ' SOLGF: OPEN 14'
C**
OPEN (14,FORM='UNFORMATTED')
IF (N1.EQ.N.OR.M1.EQ.0) GO TO 20
C REORDER CURRENT ARRAY
DO 17 I=N2,NPM
17 Y(I)=XY(I)
JJ=N1C+1
J=N1
DO 18 I=JJ,NPM
J=J+1
18 XY(J)=Y(I)
DO 19 I=N2,N1C
J=J+1
19 XY(J)=Y(I)
20 IF (NSCON.EQ.0) GO TO 22
J=NEQS-1
DO 21 I=1,NSCON
J=J+1
JJ=ISCON(I)
21 XY(JJ)=XY(J)
22 CONTINUE
C**
C D WRITE(*,*) ' SOLGF: RETURN'
C**
RETURN
END